home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / env / pacman.scm < prev    next >
Text File  |  1995-10-13  |  9KB  |  334 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; PACkage-manipulation comMANds
  5.  
  6. (add-sentinel! package-system-sentinel)
  7.  
  8.  
  9. (define (set-environment-for-commands! p)
  10.   (set-interaction-environment! p)
  11.   ;; (set-command-level-env! (command-level) p)
  12.   )
  13.  
  14. (define user-environment
  15.   (user-context-accessor 'user-environment interaction-environment))
  16. (define set-user-environment!
  17.   (user-context-modifier 'user-environment))
  18.  
  19.  
  20. (define-command-syntax 'in "<struct> [<command>]"
  21.   "go to package, or execute single command in package"
  22.   '(name &opt command))
  23.  
  24. (define (in name . maybe-command)
  25.   (if (and (not (null? maybe-command))
  26.        (command-just-evaluates-symbol? (car maybe-command)))
  27.       (set-focus-object! (environment-ref (really-get-package name)
  28.                       (cadr (car maybe-command))))
  29.       (in-package (get-package name) maybe-command)))
  30.  
  31. (define (command-just-evaluates-symbol? command)
  32.   (and (pair? command)
  33.        (not (car command))
  34.        (symbol? (cadr command))))
  35.  
  36.  
  37. (define-command-syntax 'new-package "" "make and enter a new package"
  38.   '())
  39.  
  40. (define (new-package)
  41.   (let ((p (make-simple-package (list (get-structure 'scheme))
  42.                 #t    ;unstable?
  43.                 (get-reflective-tower (user-environment))
  44.                 #f)))
  45.     (set-package-integrate?! p
  46.                  (package-integrate? (environment-for-commands)))
  47.     (set-environment-for-commands! p)))
  48.  
  49. (define (get-reflective-tower env)    ;Returns promise of (eval . env)
  50.   (reflective-tower (if (package? env)
  51.               (package->environment env)
  52.               env)))    ;Mumble
  53.  
  54.  
  55. ; load-package
  56.  
  57. (define-command-syntax 'load-package "<struct>" "load package's source code"
  58.   '(name))
  59.  
  60. (define (load-package name)
  61.   (ensure-loaded (get-structure name)))
  62.  
  63. (define-command-syntax 'reload-package "<struct>" "load package's source code again"
  64.   '(name))
  65.  
  66. (define (reload-package name)
  67.   (let ((s (get-structure name)))
  68.     (set-package-loaded?! (structure-package s) #f)
  69.     (ensure-loaded s)))
  70.  
  71. (define-command-syntax 'structure "<name> <interface>"
  72.   "create new structure over the current package"
  73.   '(name expression))
  74.  
  75. (define (structure name interface-expression)
  76.   (let* ((c (config-package))
  77.      (p (environment-for-commands))
  78.      (s (make-structure p
  79.                 (lambda ()
  80.                   (evaluate interface-expression c))
  81.                 name)))
  82.     ;; (check-structure s)
  83.     (environment-define! c name s)))
  84.  
  85.  
  86. (define-command-syntax 'open "<struct> ..." "open a structure"
  87.   '(&rest name))
  88.  
  89. (define (open . names)
  90.   (for-each (lambda (name)
  91.           (let* ((c (config-package))
  92.              (thunk (lambda () (environment-ref c name)))
  93.              (probe (thunk)))
  94.         (if (structure? probe)
  95.             (if (ensure-loaded-query probe)
  96.             (package-open! (environment-for-commands) thunk)
  97.             (error "structure not loaded" name))
  98.             (error "not a structure" name))))
  99.         names))
  100.  
  101. (define (ensure-loaded-query struct)
  102.   (let ((p (structure-package struct)))
  103.     (cond ((or (package-loaded? p)
  104.            (and (null? (package-clauses p))
  105.             (every (lambda (struct)
  106.                  (package-loaded? (structure-package struct)))
  107.                (package-opens p))))
  108.        #t)
  109.       ((or (batch-mode?)
  110.            (y-or-n? (string-append "Load structure "
  111.                        (symbol->string
  112.                     (structure-name struct)))
  113.             #f))
  114.        (ensure-loaded struct)
  115.        #t)
  116.       (else #f))))
  117.  
  118.  
  119. (define-command-syntax 'for-syntax "[<command>]"
  120.   "go to current package's package for syntax"
  121.   '(&opt command))
  122.  
  123. (define (for-syntax . maybe-command)
  124.   (in-package (cdr (force (get-reflective-tower (environment-for-commands))))
  125.     maybe-command))
  126.  
  127.  
  128. ; ,user  goes to the user initial environment.
  129.  
  130. (define-command-syntax 'user "[<command>]" "go to user package"
  131.   '(&opt command))
  132.  
  133. (define (user . maybe-command)
  134.   (in-package (user-environment) maybe-command))
  135.  
  136. (define-command-syntax 'user-package-is "[<struct>]"
  137.   "designate user package (for ,user command)"
  138.   '(&opt name))
  139.  
  140. (define (user-package-is . name-option)
  141.   (set-user-environment! (if (null? name-option)
  142.                  (environment-for-commands)
  143.                  (get-package (car name-option)))))
  144.  
  145. (define set-user-environment!
  146.   (user-context-modifier 'user-environment))
  147.  
  148.  
  149. ; Configuration package  (should there be ,load-config as well?)
  150.  
  151. (define-command-syntax 'config "[<command>]" "go to configuration package"
  152.   '(&opt command))
  153.  
  154. (define (config . maybe-command)
  155.   (in-package (config-package) maybe-command))
  156.  
  157. (define-command-syntax 'config-package-is "<struct>"
  158.   "designate configuration package"
  159.   '(name))
  160.  
  161. (define (config-package-is name)
  162.   (set-config-package! (get-package name)))
  163.  
  164.  
  165. ; ,exec  goes to the exec initial environment.
  166.  
  167. (define-command-syntax 'exec "[<command>]" "go to command execution package"
  168.   '(&opt command))
  169.  
  170. (define (exec . maybe-command)
  171.   (in-package (user-command-environment) maybe-command))
  172.  
  173.  
  174. ; ,undefine foo  removes definition of foo from current package.
  175.  
  176. (define-command-syntax 'undefine "<name>" "remove definition"
  177.   '(name))
  178.  
  179. (define (undefine name)
  180.   (package-undefine! (interaction-environment) name))
  181.  
  182.  
  183. ; --------------------
  184. ; Auxiliaries for package commands
  185.  
  186. (define (in-package p maybe-command)
  187.   (if (null? maybe-command)
  188.       (set-environment-for-commands! p)
  189.       (with-interaction-environment p
  190.     (lambda ()
  191.       (let ((command (car maybe-command)))
  192.         (if (procedure? command)
  193.         (command)
  194.         (execute-command (car maybe-command))))))))
  195.  
  196. (define config-package
  197.   (user-context-accessor 'config-package user-environment))
  198.  
  199. (define set-config-package!
  200.   (user-context-modifier 'config-package))
  201.  
  202.  
  203. (define (get-package name)
  204.   (let ((p (really-get-package name)))
  205.     (if (package-unstable? p)
  206.     p
  207.     (error "read-only structure" p))))
  208.  
  209. (define (really-get-package name)
  210.   (let ((s (get-structure name)))
  211.     (ensure-loaded-query s)
  212.     (structure-package s)))
  213.  
  214. (define (get-structure name)
  215.   (let ((thing (environment-ref (config-package) name)))
  216.     (cond ((structure? thing) thing)
  217.       (else (error "not a structure" name thing)))))
  218.  
  219.  
  220. ; Main entry point, with package setup.
  221.  
  222. (define (new-command-processor info commands built-in . meta-structs)
  223.   ;; Argument to ,build command
  224.   (lambda (arg)
  225.     (call-with-values (lambda ()
  226.             (new-user-context commands built-in meta-structs))
  227.       (lambda (context env)
  228.     (with-interaction-environment env
  229.       (lambda ()
  230.         (start-command-processor arg
  231.                      context
  232.                      ;; env
  233.                      (lambda ()
  234.                        (greet-user info)))))))))
  235.  
  236. (define (new-user-context commands built-in meta-structs)
  237.   (let* ((tower (make-reflective-tower
  238.               eval
  239.               (list (*structure-ref built-in 'scheme))
  240.               'user))
  241.      (user (make-user-package built-in tower))
  242.      (config-package (make-config-package 'config
  243.                           tower
  244.                           built-in
  245.                           meta-structs))
  246.      (exec-package (make-exec-package commands tower built-in)))
  247.     (values (make-user-context
  248.          (lambda ()
  249.            (set-user-environment! user)
  250.            (set-config-package! config-package)
  251.            (set-user-command-environment! exec-package)))
  252.         user)))
  253.  
  254. ; User package
  255.  
  256. (define (make-user-package built-in tower)
  257.   (let* ((scheme-structure (*structure-ref built-in 'scheme))
  258.      (user
  259.       (make-simple-package (list scheme-structure)
  260.                    #t  ;unstable?
  261.                    tower
  262.                    'user)))
  263.     (set-package-integrate?! user #f)
  264.     (environment-define! user 'access-scheme-48 access-scheme-48)
  265.     user))
  266.  
  267. (define (access-scheme-48 name)        ;For PSD and SLIB, ugh.
  268.   (case name
  269.     ((error) error)
  270.     ((ascii->char) ascii->char)
  271.     ((force-output) force-output)
  272.     ((error-output-port) error-output-port)
  273.     (else (call-error "unrecognized name" access-scheme-48 name))))
  274.  
  275. ; Configuration package
  276.  
  277. (define (make-config-package name tower built-in meta-structs)
  278.   (let* ((module-system (*structure-ref built-in 'module-system))
  279.      (config
  280.       (make-simple-package (cons module-system
  281.                      (append meta-structs
  282.                          (list built-in)))
  283.                    #t  ;unstable?
  284.                    tower
  285.                    name)))
  286.     (set-reflective-tower-maker!
  287.          config
  288.      (lambda (clauses id)
  289.        (if (null? clauses)
  290.            tower            ;?
  291.            (delay (let ((p (eval `(a-package ((for-syntax ,id)) ,@clauses)
  292.                      config)))
  293.             (ensure-loaded (make-structure p
  294.                                (lambda () (make-simple-interface #f '()))
  295.                                'for-syntax))
  296.             (cons eval p))))))
  297.     config))
  298.  
  299. ; Exec package
  300.  
  301. (define (make-exec-package commands tower built-in)
  302.   (make-simple-package (list commands (*structure-ref built-in 'scheme))
  303.                #t        ;unstable?
  304.                tower
  305.                'exec))
  306.  
  307. ; for prompt string
  308.  
  309. (define-method &environment-id-string ((env :package))
  310.   (if (eq? env (user-environment))
  311.       ""
  312.       (if (symbol? (package-name env))
  313.       (symbol->string (package-name env))
  314.       (number->string (package-uid env)))))
  315.  
  316. (define user-environment
  317.   (user-context-accessor 'user-environment interaction-environment))
  318.  
  319. ; Extract a package-specific evaluator from a package.  Eventually, it
  320. ; would be nice if load, eval-from-file, eval-scanned-forms, and
  321. ; perhaps other things were also generic over different kinds of
  322. ; environments.
  323.  
  324. (define funny-name/evaluator (string->symbol ".evaluator."))
  325.  
  326. (define (set-package-evaluator! p evaluator)
  327.   (package-define-funny! p funny-name/evaluator evaluator))
  328.  
  329. (define (package-evaluator p)
  330.   (or (get-funny (package->environment p) funny-name/evaluator) eval))
  331.  
  332. (define-method &evaluate (form (env :package))
  333.   ((package-evaluator env) form env))
  334.